home *** CD-ROM | disk | FTP | other *** search
/ PC Plus SuperCD (UK) 1995 August / PC Plus Super CD (Issue 106) (PCP106) (August 1995).iso / pcplus / handson / wilf / soundex.bas < prev   
Encoding:
BASIC Source File  |  1995-07-31  |  3.8 KB  |  196 lines
  1. ' This demonstrates SOUNDEX
  2. '
  3.  
  4. DECLARE SUB RFIELD (Field$, Min%, Max%, Permitted$)
  5.  
  6. SCREEN 9
  7. COLOR 15, 2
  8. CLS
  9.  
  10. '************************
  11. LOCATE 2, 1
  12. PRINT "Enter a word for SOUNDEX treatment:"
  13.  
  14.  
  15. LINE (218, 49)-(354, 76), 1, BF
  16. LINE (221, 51)-(351, 74), 0, BF
  17.  
  18.  
  19. LOCATE 5, 30
  20. COLOR 8
  21. CALL RFIELD(Field$, 1, 12, "CX")
  22.  
  23. '************************
  24. ' get rid of doubled letters
  25.  
  26. FOR i% = 2 TO LEN(Field$)
  27.  x1$ = MID$(Field$, i% - 1, 1)
  28.  x2$ = MID$(Field$, i%, 1)
  29.  IF x1$ = x2$ THEN
  30.   MID$(Field$, i% - 1, 1) = " "
  31.  END IF
  32. NEXT
  33.  
  34.  
  35. '************************
  36. ' convert letters (except first)
  37.  
  38. FOR i% = 2 TO LEN(Field$)
  39.  j% = INSTR("ABCDEFGHIJKLMNOPQRSTUVWXYZ ", MID$(Field$, i%, 1))
  40.  MID$(Field$, i%, 1) = MID$(" 123 12  22455 12623 1 2 2 ", j%, 1)
  41. NEXT
  42.  
  43.  
  44. '************************
  45. ' gather valid letters
  46.  
  47. Field$ = Field$ + "000"
  48. j% = 2
  49. FOR i% = 2 TO LEN(Field$)
  50.  x$ = MID$(Field$, i%, 1)
  51.  IF x$ <> " " THEN
  52.   MID$(Field$, j%, 1) = x$
  53.   IF i% <> j% THEN
  54.    MID$(Field$, i%, 1) = " "
  55.   END IF
  56.   j% = j% + 1
  57.  END IF
  58. NEXT
  59.  
  60. '************************
  61. ' shorten to four characters
  62.  
  63. Field$ = LEFT$(Field$, 4)
  64. LINE (242, 161)-(306, 188), 1, BF
  65. LINE (245, 163)-(303, 186), 0, BF
  66. LOCATE 13, 33
  67. PRINT Field$;
  68.  
  69.  
  70. SUB RFIELD (Field$, Min%, Max%, Permitted$)
  71.  
  72. ' locate the field on the screen
  73. atRow% = CSRLIN
  74. atCol% = POS(x)
  75.  
  76. ' clear the field on the screen
  77. Field$ = ""
  78. PRINT CHR$(219); SPACE$(Max%);
  79.  
  80. ' set the brake and loop until done
  81. Brake% = 1
  82.  
  83. WHILE Brake%
  84.  
  85. ' get a keystroke
  86.  x$ = ""
  87.  WHILE LEN(x$) = 0
  88.   x$ = INKEY$
  89.  WEND
  90.  
  91. ' convert to uppercase if specified
  92.  IF INSTR(Permitted$, "C") THEN x$ = UCASE$(x$)
  93.  oldLen% = LEN(Field$)
  94.  
  95. ' test for permitted keystroke
  96.  Good% = 0
  97.  IF INSTR(Permitted$, ".") THEN
  98.   IF x$ = "." THEN
  99.    IF INSTR(Field$, ".") = 0 THEN Good% = 1
  100.   END IF
  101.  END IF
  102.  IF INSTR(UCASE$(Permitted$), "N") THEN
  103.   IF INSTR("0123456789", x$) THEN Good% = 1
  104.  END IF
  105.  IF INSTR(UCASE$(Permitted$), "S") THEN
  106.   IF x$ = " " THEN Good% = 1
  107.  END IF
  108.  IF INSTR(UCASE$(Permitted$), "X") THEN
  109.   IF INSTR("ABCDEFGHIJKLMNOPQRSTUVWXYZ", UCASE$(x$)) THEN
  110.    Good% = 1
  111.   END IF
  112.  END IF
  113.  IF INSTR(UCASE$(Permitted$), "Y") THEN
  114.   IF INSTR("YyNy", x$) THEN Good% = 1
  115.  END IF
  116.  IF Good% THEN
  117.   Field$ = Field$ + x$
  118.   IF INSTR(Field$, ".") THEN
  119.    NewMax% = Max% + 1
  120.   ELSE
  121.    NewMax% = Max%
  122.   END IF
  123.   Field$ = MID$(Field$, 1, NewMax%)
  124.  END IF
  125.  
  126. ' handle Bkspace
  127.  IF ASC(x$) = 8 AND LEN(Field$) THEN
  128.   Field$ = MID$(Field$, 1, LEN(Field$) - 1)
  129.  END IF
  130.  
  131. ' calculate significant digits
  132.  Signif$ = Field$ + "X"
  133.  WHILE INSTR(" 0", MID$(Signif$, 1, 1))
  134.   Signif$ = MID$(Signif$, 2)
  135.  WEND
  136.  IF INSTR(Signif$, ".") THEN
  137.   SignifLen% = LEN(Signif$) - 2
  138.  ELSE
  139.   SignifLen% = LEN(Signif$) - 1
  140.  END IF
  141.  
  142. ' handle Enter
  143.  IF ASC(x$) = 13 AND SignifLen% >= Min% THEN
  144.   oldLen% = LEN(Field$) + 1
  145.   Brake% = 0
  146.  END IF
  147.  
  148. ' handle Esc
  149.  IF ASC(x$) = 27 THEN
  150.   LOCATE atRow%, atCol%
  151.   PRINT CHR$(219); SPACE$(Max%);
  152.   Field$ = ""
  153.   IF INSTR(UCASE$(Permitted$), "E") THEN
  154.    RETURN
  155.   END IF
  156.  END IF
  157.  
  158. ' reprint if change, or beep if no change
  159.  IF oldLen% = LEN(Field$) THEN
  160.   BEEP
  161.  ELSE
  162.   LOCATE atRow%, atCol%
  163.   IF INSTR(UCASE$(Permitted$), "P") THEN
  164.    PRINT STRING$(LEN(Field$), 254); CHR$(219); " ";
  165.   ELSE
  166.    PRINT Field$; CHR$(219); " ";
  167.   END IF
  168.  END IF
  169.  
  170. ' check for auto-Enter
  171.  IF INSTR(UCASE$(Permitted$), "A") THEN
  172.   IF SignifLen% = Max% THEN
  173.    Brake% = 0
  174.   END IF
  175.  END IF
  176. WEND
  177.  
  178. ' justify if required
  179. IF INSTR(UCASE$(Permitted$), "J") THEN
  180.  WHILE MID$(Field$, 1, 1) = "0"
  181.   Field$ = MID$(Field$, 2)
  182.  WEND
  183.  Field$ = RIGHT$(SPACE$(NewMax%) + Field$, NewMax%)
  184. END IF
  185.  
  186. ' reprint, deleting the cursor
  187. LOCATE atRow%, atCol%
  188. IF INSTR(UCASE$(Permitted$), "P") THEN
  189.  PRINT STRING$(LEN(Field$), 254); " ";
  190. ELSE
  191.  PRINT Field$; " ";
  192. END IF
  193.  
  194. END SUB
  195.  
  196.